home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Lib / error.stk < prev    next >
Encoding:
Text File  |  1996-07-07  |  8.4 KB  |  268 lines
  1. ;;;;
  2. ;;;; e r r o r . s t k         -- All the stuff going with error messages 
  3. ;;;;                   display
  4. ;;;;
  5. ;;;;
  6. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  7. ;;;; 
  8. ;;;; Permission to use, copy, and/or distribute this software and its
  9. ;;;; documentation for any purpose and without fee is hereby granted, provided
  10. ;;;; that both the above copyright notice and this permission notice appear in
  11. ;;;; all copies and derived works.  Fees for distribution or use of this
  12. ;;;; software or derived works may only be charged with express written
  13. ;;;; permission of the copyright holder.  
  14. ;;;; This software is provided ``as is'' without express or implied warranty.
  15. ;;;;
  16. ;;;;
  17. ;;;;           Author: Erick Gallesio [eg@unice.fr]
  18. ;;;;    Creation date: 15-Sep-1993 14:11
  19. ;;;; Last file update:  7-Jul-1996 17:14
  20. ;;;;
  21.  
  22. (require "dialog")
  23.  
  24. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  25. ;;;;
  26. ;;;; report-error (this version of report-error needs Tk)
  27. ;;;;
  28. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29.  
  30. (define (STk:report-error head message obj)
  31.   ;; Since this function is loaded only when needed the stack is different 
  32.   ;; on first execution 
  33.   (define stack       (cddddr (%get-eval-stack)))
  34.   (define env         (cddddr (%get-environment-stack)))
  35.   (define current-env (global-environment))
  36.  
  37.   (define (truncate s len)
  38.     (if (> (string-length s) len)
  39.     (string-append (substring s 0 (- len 1)) " ...")
  40.     s))
  41.  
  42.   (define (adjust-string s len)
  43.     (let ((l (string-length s)))
  44.       (if (>= l len)
  45.       s
  46.       (string-append s (make-string (- len l) #\space)))))
  47.  
  48.   (define (local-eval x)
  49.     (eval x current-env))
  50.  
  51.   (define (select-expression |W| x y)
  52.     (let ((index (|W| 'index (format #f "@~a,~a" x y))))
  53.       (when (< index (length stack))
  54.     (set! current-env (list-ref env index))
  55.     (listener-insert-string .stackview.vt.l
  56.                 (format #f ";; Current environment is ~A\n"
  57.                     (if (eq? current-env (global-environment))
  58.                         "global environment"
  59.                         current-env))))))
  60.  
  61.   (define (select-environment |W| x y)
  62.     (let ((index (|W| 'index (format #f "@~a,~a" x y))))
  63.       (display-environment (if (= index (length env))
  64.                    (global-environment)
  65.                    (list-ref env index)))))
  66.  
  67.   (define (display-environment e)
  68.     (let* ((top      (gensym ".top_env"))
  69.        (f1       (format #f "~A.f"        top))
  70.        (lst      (format #f "~A.f.lst"    top))
  71.        (scroll-x (format #f "~A.f.sx"     top))
  72.        (scroll-y (format #f "~A.f.sy"     top))
  73.        (f2         (format #f "~A.b"          top))
  74.        (parent   (format #f "~A.b.parent" top))
  75.        (quit     (format #f "~A.b.quit"   top))
  76.        (el         (car (environment->list e))))
  77.  
  78.       (toplevel top)
  79.       (wm 'title top (format #f "~S" e))
  80.       (pack (frame f1) (frame f2) :expand #t :fill "both" :side "top")
  81.  
  82.       ;;;;;  Listbox and its scrollbar
  83.       (set! lst (listbox lst :width 70 :height (max 2 (min (length el) 20))
  84.              :font "fixed"
  85.              :xscroll (lambda args (apply scroll-x 'set args))
  86.              :yscroll (lambda args (apply scroll-y 'set args))))
  87.       (set! scroll-x (scrollbar scroll-x :orient "hor" 
  88.                 :command (lambda args (apply lst 'xview args))))
  89.       (set! scroll-y (scrollbar scroll-y :orient "ver"
  90.                 :command (lambda args (apply lst 'yview args))))
  91.  
  92.       (pack scroll-x :side "bottom" :fill "x")
  93.       (pack lst :expand #t :fill "both" :side "left")
  94.       (pack scroll-y :side "left"   :fill "y")
  95.  
  96.       ;; fill it
  97.       (let ((bindings (map (lambda (x) 
  98.                  (format #f "~A = ~S" 
  99.                      (adjust-string (symbol->string (car x)) 20)
  100.                      (cdr x)))
  101.                el)))
  102.     (apply lst 'insert 0 (sort bindings string<?)))
  103.  
  104.       ;; Parent and quit button
  105.       (let ((p (parent-environment e)))
  106.     (pack (button quit 
  107.               :text "Quit" :command (lambda () (destroy top)))
  108.           (button parent
  109.               :text "Parent environment" 
  110.               :state (if p "normal" "disabled")
  111.               :command (lambda () (display-environment p)))
  112.         :expand #t :fill "x" :side "left"))))
  113.  
  114.  
  115.   (define (display-stack stack env)
  116.     (catch (destroy ".stackview"))
  117.  
  118.     ;; Build a toplevel
  119.     (toplevel '.stackview)
  120.     (wm 'title .stackview "STk stack")
  121.  
  122.     ;; Dispose items
  123.     (pack (label '.stackview.l :text "Stack content" :fg "RoyalBlue")
  124.       :side "top")
  125.     (pack (frame '.stackview.f :bd 3 :relief "groove")
  126.       :side "top" :expand #t :fill "both" :padx 5 :pady 5)
  127.     (pack (frame '.stackview.b)
  128.       :side "bottom" :fill "x")
  129.  
  130.     ;;;;;;;;;;;;;;;;;;;;
  131.     ;;
  132.     ;; The (double) listbox
  133.     ;;
  134.     ;;;;;;;;;;;;;;;;;;;;
  135.     (pack (scrollbar '.stackview.f.sx 
  136.              :orient "hor" 
  137.              :command (lambda args 
  138.                 (apply .stackview.f.list 'xview args)))
  139.       :side "bottom" :fill "x")
  140.  
  141.     (pack (listbox '.stackview.f.env 
  142.            :width  18
  143.            :height 10
  144.            :font "fixed"
  145.            :bd 1
  146.            :relief "raised")
  147.       :expand #f :fill "y" :side "left")
  148.  
  149.     (pack (listbox '.stackview.f.list 
  150.            :width  70
  151.            :height 10
  152.            :font "fixed"
  153.            :bd 1
  154.            :relief "raised"
  155.            :xscroll (lambda args (apply .stackview.f.sx 'set args))
  156.            :yscroll (lambda args (apply .stackview.f.sy 'set args)))
  157.       :expand #t :fill "both" :side "left")
  158.  
  159.     (pack (scrollbar '.stackview.f.sy
  160.              :orient "vert"
  161.              :command (lambda args 
  162.                 (apply .stackview.f.list 'yview args)))
  163.       :side "left" :fill "y")
  164.  
  165.     ;; Insert the stack elements in the listbox
  166.     (do ((stack stack (cdr stack))
  167.      (env   env   (cdr env)))
  168.     ((null? stack))
  169.       (.stackview.f.list 'insert 'end 
  170.              (truncate (format #f "~S" (uncode(car stack))) 150))
  171.       (.stackview.f.env 'insert 'end 
  172.             (format #f "~A" 
  173.                 (if (equal? (car env) (global-environment))
  174.                     "*global*"
  175.                     (address-of (car env))))))
  176.  
  177.     ;; Insert a marker to delimit bottom of the stack
  178.     (.stackview.f.list 'insert 'end "<<< STACK BOTTOM >>>")
  179.     (.stackview.f.env  'insert 'end "*global*")
  180.  
  181.     ;; listbox bindings
  182.     (bind .stackview.f.env  "<ButtonRelease-1>" select-environment)
  183.     (bind .stackview.f.list "<ButtonRelease-1>" select-expression)
  184.  
  185.     ;;;;;;;;;;;;;;;;;;;;
  186.     ;;;;
  187.     ;;;; Listener
  188.     ;;;;
  189.     ;;;;;;;;;;;;;;;;;;;;
  190.     (pack (label '.stackview.l2 :text "Listener" :fg "RoyalBlue")
  191.       :side "top")
  192.  
  193.     (pack (frame '.stackview.vt :bd 3 :relief "groove") 
  194.       :expand #t :fill "both" :padx 5 :pady 5)
  195.     (pack (listener '.stackview.vt.l 
  196.             :font   "fixed" 
  197.             :wrap   "word" 
  198.             :height 10
  199.             :command (lambda (x) (format #f "~S" 
  200.                          (eval-string x current-env)))
  201.             :yscroll (lambda args (apply .stackview.vt.s 'set args)))
  202.       :side "left" :expand #t :fill "both")
  203.     (pack (scrollbar '.stackview.vt.s
  204.              :orient "vert"
  205.              :command (lambda args (apply .stackview.vt.l 'yview args)))
  206.       :side "right" :expand #f :fill "y")
  207.     ;;;;;;;;;;;;;;;;;;;;
  208.     ;;
  209.     ;; Bottom buttons
  210.     ;;
  211.     ;;;;;;;;;;;;;;;;;;;;
  212.     (pack [button '.stackview.b.q 
  213.           :text "Quit"
  214.           :command (lambda () (destroy .stackview))]
  215.       [button '.stackview.b.h 
  216.           :text "Help"
  217.           :command (lambda () 
  218.                  (STk:show-help-file "error-hlp.html"))]
  219.      :side "left" :expand #t :fill "x")
  220.  
  221.     ;; Center the window
  222.     (STk:center-window .stackview))
  223.  
  224.   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  225.   ;;;;
  226.   ;;;; Report-error starts here
  227.   ;;;; 
  228.   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  229.   (let* ((who (if (null? obj) "" (format #f "~S" obj)))
  230.      (msg (truncate (string-append head "\n" message "\n" who "\n") 200)))
  231.  
  232.     ;; Print message on standard error stream
  233.     (format (current-error-port) "\n~A~A~A\n" 
  234.         head 
  235.         message 
  236.         (if (equal? who "") "" (string-append ": " who)))
  237.  
  238.     ;; Open dialog box
  239.     (stk::make-dialog 
  240.         :window   '.report-error
  241.         :title    "STk error"
  242.         :text     msg
  243.         :bitmap   "error"
  244.         :grab     #f
  245.         :default  0
  246.         :buttons  `(("    Quit     " ,(lambda () '()))
  247.             ("See the stack" ,(lambda ()
  248.                         (display-stack stack env)))))))
  249.  
  250. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  251. ;;;;
  252. ;;;; Misc 
  253. ;;;;
  254. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  255.  
  256. (define *error-info* "")
  257.  
  258. (define (bgerror . message)
  259.   ;; Important note: When a background error occurs, tk try to see if 
  260.   ;; bgerror is bound to something. This is achieved by calling bgerror
  261.   ;; with an empty message. In this case, nothing is printed
  262.   (unless (null? message)
  263.       (format (current-error-port) "**** Tk error (~S) ~S~%" 
  264.           (car message) *error-info*))
  265.   (set! *error-info* ""))
  266.  
  267. (define tkerror bgerror) ;; For compatibility with pre-Tk4.1 (i.e STk-3.1)
  268.